home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-undo.el < prev    next >
Encoding:
Text File  |  1991-04-06  |  7.4 KB  |  202 lines
  1. ;;; Commands to undo message attribute changes in VM
  2. ;;; Copyright (C) 1989, 1990 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (defun vm-set-buffer-modified-p (flag &optional clear-modflags buffer)
  19.   (save-excursion
  20.     (and buffer (set-buffer buffer))
  21.     (if (eq (setq flag (not (not flag))) vm-buffer-modified-p)
  22.     ()
  23.       (set-buffer-modified-p flag)
  24.       (vm-increment vm-modification-counter)
  25.       (if (null flag)
  26.       (let ((mp vm-message-list))
  27.         (setq vm-messages-not-on-disk 0)
  28.         (if clear-modflags
  29.         (while mp
  30.           (vm-set-modflag-of (car mp) nil)
  31.           (setq mp (cdr mp))))))
  32.       (setq vm-buffer-modified-p (if flag "--**-")))))
  33.  
  34. (defun vm-sanity-check-modification-flag ()
  35.   ;; this is possible if the user used a normal buffer save command instead of
  36.   ;; vm-save-folder...
  37.   (if (not (eq (not (not vm-buffer-modified-p)) (buffer-modified-p)))
  38.       (vm-set-buffer-modified-p (buffer-modified-p))))
  39.  
  40. (defun vm-undo-boundary ()
  41.   (if (car vm-undo-record-list)
  42.       (setq vm-undo-record-list (cons nil vm-undo-record-list))))
  43.  
  44. (defun vm-clear-expunge-invalidated-undos (&optional real-folder)
  45.   (let ((udp vm-undo-record-list) udp-prev)
  46.     (while udp
  47.       (cond ((null (car udp))
  48.          (setq udp-prev udp))
  49.         ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p))
  50.           (vm-deleted-flag (car (cdr (car udp))))
  51.           (or (null real-folder)
  52.               (eq real-folder (marker-buffer
  53.                        (vm-start-of (car (cdr (car udp))))))))
  54.          (cond (udp-prev (setcdr udp-prev (cdr udp)))
  55.            (t (setq vm-undo-record-list (cdr udp)))))
  56.         (t (setq udp-prev udp)))
  57.       (setq udp (cdr udp)))
  58.     (and (null real-folder) vm-virtual-buffers
  59.      (let ((b-list vm-virtual-buffers)
  60.            (curbuf (current-buffer)))
  61.        (save-excursion
  62.          (while b-list
  63.            (set-buffer (car b-list))
  64.            (vm-clear-expunge-invalidated-undos curbuf)
  65.            (setq b-list (cdr b-list))))))
  66.     (vm-clear-modification-flag-undos real-folder)))
  67.         
  68. (defun vm-clear-modification-flag-undos (&optional real-folder)
  69.   (let ((udp vm-undo-record-list) udp-prev)
  70.     (while udp
  71.       (cond ((null (car udp))
  72.          (setq udp-prev udp))
  73.         ((and (eq (car (car udp)) 'vm-set-buffer-modified-p)
  74.           (or (null real-folder)
  75.               (eq real-folder (vm-last (car udp)))))
  76.          (cond (udp-prev (setcdr udp-prev (cdr udp)))
  77.            (t (setq vm-undo-record-list (cdr udp)))))
  78.         (t (setq udp-prev udp)))
  79.       (setq udp (cdr udp)))
  80.     (vm-squeeze-consecutive-undo-boundaries)
  81.     (and (null real-folder) vm-virtual-buffers
  82.      (let ((b-list vm-virtual-buffers)
  83.            (curbuf (current-buffer)))
  84.        (save-excursion
  85.          (while b-list
  86.            (set-buffer (car b-list))
  87.            (vm-clear-modification-flag-undos curbuf)
  88.            (setq b-list (cdr b-list))))))))
  89.  
  90. ;; squeeze out consecutive record separators left by record deletions
  91. (defun vm-squeeze-consecutive-undo-boundaries ()
  92.   (let ((udp vm-undo-record-list) udp-prev)
  93.     (while udp
  94.       (cond ((and (null (car udp)) udp-prev (null (car udp-prev)))
  95.          (setcdr udp-prev (cdr udp)))
  96.         (t (setq udp-prev udp)))
  97.       (setq udp (cdr udp)))
  98.     (if (equal '(nil) vm-undo-record-list)
  99.     (setq vm-undo-record-list nil))))
  100.         
  101. (defun vm-undo-record (sexp)
  102.   (setq vm-undo-record-list (cons sexp vm-undo-record-list)))
  103.  
  104. (defun vm-undo ()
  105.   "Undo last change to message attributes in the current folder.
  106. Consecutive invocations of this command cause sequentially earlier
  107. changes to be undone.  After an intervening command between undos,
  108. the undos themselves become undoable."
  109.   (interactive)
  110.   (vm-select-folder-buffer)
  111.   (vm-check-for-killed-summary)
  112.   (let ((inhibit-quit t)
  113.     (modified (buffer-modified-p)))
  114.     (if (not (eq last-command 'vm-undo))
  115.     (setq vm-undo-record-pointer vm-undo-record-list))
  116.     (if (not vm-undo-record-pointer)
  117.     (error "No further VM undo information available"))
  118.     ;; skip current record boundary
  119.     (setq vm-undo-record-pointer (cdr vm-undo-record-pointer))
  120.     (while (car vm-undo-record-pointer)
  121.       (eval (car vm-undo-record-pointer))
  122.       (setq vm-undo-record-pointer (cdr vm-undo-record-pointer)))
  123.     (message "VM Undo!")
  124.     (and modified (not (buffer-modified-p))
  125.      (delete-auto-save-file-if-necessary))
  126.     (vm-update-summary-and-mode-line)))
  127.  
  128. (defun vm-set-xxxx-flag (m flag norecord function attr-index)
  129.   (let* ((inhibit-quit t) m-list modflag-buffer mirror
  130.      (virtual (not (eq m (vm-real-message-of m))))
  131.      (read-only (save-excursion
  132.               (set-buffer
  133.                (marker-buffer (if virtual
  134.                      (vm-su-start-of m)
  135.                        (vm-start-of m))))
  136.               vm-folder-read-only)))
  137.     (and (eq (vm-attributes-of m) (vm-attributes-of (vm-real-message-of m)))
  138.      (setq m (vm-real-message-of m)
  139.            mirror t))
  140.     (cond ((not read-only)
  141.        (aset (vm-attributes-of m) attr-index flag)
  142.        (vm-mark-for-display-update m)))
  143.     (if (and (not norecord) (not read-only))
  144.     (progn
  145.       (save-excursion
  146.         (set-buffer 
  147.          (marker-buffer
  148.           (if (and virtual (not mirror))
  149.           (vm-su-start-of m)
  150.         (vm-start-of m))))
  151.         (cond ((not vm-buffer-modified-p)
  152.            (setq modflag-buffer (current-buffer))
  153.            (vm-set-buffer-modified-p t)
  154.            (vm-undo-record (list 'vm-set-buffer-modified-p nil))
  155.            (setq vm-totals nil)))
  156.         (vm-undo-record (list function m (not flag)))
  157.         (vm-undo-boundary)
  158.         (vm-increment vm-modification-counter)
  159.         (if (eq vm-flush-interval t)
  160.         (vm-stuff-virtual-attributes m)
  161.           (vm-set-modflag-of m t)))
  162.       (setq m-list (vm-virtual-messages-of m))
  163.       (and m-list
  164.            (save-excursion
  165.          (while m-list
  166.            (set-buffer (marker-buffer (vm-su-start-of (car m-list))))
  167.            (and modflag-buffer
  168.             (vm-undo-record
  169.              (list 'vm-set-buffer-modified-p nil nil modflag-buffer)))
  170.            (vm-undo-record (list function m (not flag)))
  171.            (vm-undo-boundary)
  172.            (vm-increment vm-modification-counter)
  173.            (setq vm-totals nil)
  174.            (setq m-list (cdr m-list)))))))))
  175.  
  176. (defun vm-set-new-flag (m flag &optional norecord)
  177.   (vm-set-xxxx-flag m flag norecord 'vm-set-new-flag 0))
  178.  
  179. (defun vm-set-unread-flag (m flag &optional norecord)
  180.   (vm-set-xxxx-flag m flag norecord 'vm-set-unread-flag 1))
  181.  
  182. (defun vm-set-deleted-flag (m flag &optional norecord)
  183.   (vm-set-xxxx-flag m flag norecord 'vm-set-deleted-flag 2))
  184.  
  185. (defun vm-set-filed-flag (m flag &optional norecord)
  186.   (vm-set-xxxx-flag m flag norecord 'vm-set-filed-flag 3))
  187.  
  188. (defun vm-set-replied-flag (m flag &optional norecord)
  189.   (vm-set-xxxx-flag m flag norecord 'vm-set-replied-flag 4))
  190.  
  191. (defun vm-set-written-flag (m flag &optional norecord)
  192.   (vm-set-xxxx-flag m flag norecord 'vm-set-written-flag 5))
  193.  
  194. (defun vm-set-forwarded-flag (m flag &optional norecord)
  195.   (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 6))
  196.  
  197. ;; this is solely for the use of vm-stuff-attributes and appears here
  198. ;; only because this function should be grouped with others of its kind
  199. ;; together for maintenance purposes.
  200. (defun vm-set-deleted-flag-in-vector (v flag)
  201.   (aset v 2 flag))
  202.